; ORIGINAL: 3dt2.1/examples/cmdproc.scm
; $Id: cmdproc.scm,v 1.4 1997/04/30 20:24:07 jread Exp $
;----------------------------------------------------------------------
; Purpose---
;    An alternate command processor to that in cmd.scm
;
;----------------------------------------------------------------------
;
; An event-driven command processor.
;
; This program accepts descriptions of tasks, and executes those tasks.  Each task consists
; of a "target function" to be called (such as solid:block) together with a description of how
; the arguments to this function are to be collected from the user.  The task is then processed
; by the command processor as follows: Each of the arguments are collected from the user...
; when all of the arguments have been collected, the command processor invokes the given
; function on the arguments it has collected.
;
; For example, a task may specify that two positions are to be collected from the user via
; mouse clicks, and that these two positions are then to be passed to the function
; solid:block to create a solid block.
;
; Facilities are provided so that at any point during the execution of the task, the task may
; be interrupted and resumed, restarted, or even aborted.
;
; Various options may be employed that determine the relationship between the specified
; task and the "currently executing" task, if such exists.  For example, it may be specified
; that the task should be an "override task", that is, that the task should replace the
; current task. Or the task may be tagged as an "interrupt task", whereby the
; currently executing task (if such a task exists) is temporarily interrupted while the task
; is executed, to be "resumed" when the task is complete.  Or the task may be tagged as a
; "restart task", meaning that once it is executed, the prevous task should be restarted (that
; is, the command processor should start the collection of arguments over).  Override
; tasks may also be tagged as "repeating tasks" that cycle repeatedly until overriden
; by another task.  These options are specified when the task is passed to the
; command processor.

;
; General
;
; The command processor is initiated by (cmd:init), and is terminated by (cmd:clear).
; The instruction (cmd:reset) resets the command processor to its initial state (in which
; no tasks are executing).
;
; The command (cmd:interrupt?) returns #t if the current task is an interrupt task (that is,
; it is interrupting another task).
;
; (cmd:restart-task) restarts the current task from the beginning, and (cmd:abort-task)
; aborts the current task, reinstating the interrupted task if such exists.  The command
; (cmd:abort-interrupts) aborts all interrupt tasks, so that the current task becomes the
; last task that is tagged as an override and repeat task, if such exists.
;
; Improvements that could be made to this code:  It might be useful if each task could specify
; a "cleanup" procedure that would be called whenever the task was interrupted or
; aborted.

;
; Tasks
;
; Each task contains a target function and zero or more argument descriptions,
; plus optional arguments described below:
;
; (cmd:make-task
;     (cmd:task-target <target function>)
;     (cmd:task-arguments <description of arguments to be collected, see below>)
;     (cmd:task-preprocessor <function to be called on the collected arguments before
;                                                                                      they are passed to the target function>)
;     (cmd:task-postprocessor <function to be called on the result returned by the target function>))
;
; The arguments may be given in any order.  The task-target specifies the target procedure.
; The task-arguments specify the arguments to be collected, in a manner described beow.
;
; The task-preprocessor is optional.  If provided it is invoked on a single argument, a list
; containing the collected arguments to the target function.  It must return a list
; of the actual arguments that should be passed to the target function.  By default, the
; preprocessor is the identity function, simply returning the list of arguments unaltered.  Note
; that the preprocessor may actually reduce or increase the number of arguments passed to
; the target function as well as altering the arguments themselves.  The pre-processor may
; also call either of the commands (cmd:restart-task) and (cmd:abort-task) to restart
; and abort the task, respectively.  If either of these commands are issued, the return value
; of the pre-processor is ignored and the target procedure is NOT called.
;
; The task-postprocessor is also optional.  If given it is invoked on the result
; returned by the target function.  It too may also restart the task by calling (cmd:restart-task),
; however, aborting the task using (cmd:abort-task) will have no effect, since the current
; invocation of the task is automatically aborted after the post-processor is called.
;
; The pre- and post-processors are particularly useful for debugging.  Use the display
; procedure to write out the arguments to the ACIS window in order to see which
; arguments are passed to the target.  But in the pre-processor, don't forget to return the
; arguments as the value of the procedure, otherwise you will get errors indicating that
; the target procedure's arguments are not of the expected type, or there are too few or
; too many of them.

;
; Argument descriptions.
;
; Each argument description is built by the function cmd:make-argument, and contains
; information about what to do prior to collecting the argument and how to collect it.
;
; (cmd:make-argument
;     ; the do-before instructions come first
;     (cmd:arg <instructions to be executed prior to collection of the argument>)
;     ; the do-after instructions come second
;     (cmd:arg <instructions to be executed after the user has generated an event>))
;
; [Note: cmd:arg is a macro that simply wraps the instructions in a lambda-expression.]
;
; In each argument to cmd:make-argument, the instructions may be any scheme commands,
; plus any of the following:
;
;  (args-so-far)
;  Returns a list of the arguments collected to this point in the process.
;
;  (the-event)
;  Returns the last event generated by the user.
;
;  (collect <object>)
;  Adds the specified object to the list of collected objects.  Since the do-before instruction
;  set may be called several times by the command processor (for example, it is called when a
;  task has been interrupted and is being resumed, so that any instructions in the do-before
; set that affect the user interface (for example, a prompt) can be be executed), it is generally
; not desirable to use the collect command in the do-before instruction set.
;
;  (discard <object>)
;  Discards the specified object from the list of collected objects.  See comments about
;  collect command, immediately above.
;
;  (again)
;  This causes the current argument to be recollected.  The arguments collected so far are
;  reverted to the state prior to the first attempt to collect this argument.
;
; (repeat)
;  Instructs the command processor to begin collecting this argument again.  Note that the
;  arguments collected so far are NOT reverted.  So this command is useful for implementing
;  loops ... for example, for collecting entities with left mouse button presses until the right
;  mouse button is pressed.
;
; [Notes:
; (1) (repeat) and (again), and calls to either of the procedures cmd:abort-task or
; cmd:restart-task cause further execution of the current instruction set to be aborted.
; For example, if the instruction set contains the command
;                            (begin
;                                (repeat)
;                                (collect pos))
; then the (collect pos) instruction will never be executed.
; (2) To make these commands available to procedures called from within an instruction
; set, simply pass the required commands as arguments, as in this example:
;        (arg:cmd  (rbd:clear) (do-my-own-thing again collect (the-event)) (system:bell))
; where, perhaps,
;        (define do-my-own-thing
;            (lambda (again collect event)
;               (if (not happy)
;                    (again)
;                    (collect event))))
;
; For example, here is an argument description that causes the command processor to
; behave as follows:  First, the prompt "Please click" is displayed.  When the user clicks,
; a position is added to the collection of arguments unless the right mouse button was used,
; in which case the task is restarted from the beginning:
;
;     (cmd:task-arguments
;        (cmd:arg (ui:prompt "Please click"))
;        (cmd:arg (let ((pos (pick:position evt))
;                               (button (pick:button evt)))
;                           (if (equal? button right-button)
;                                (begin (system:bell) (restart))
;                                (collect pos))))))
;
; More advanced examples may be found elsewhere.

;
; Installing tasks.
;
; Tasks are executed by one of the following calls:
;
; (cmd:execute <task>)
; This causes the command processor to execute the task once.  When the command
; is done, the command processor becomes idle.
;
; (cmd:execute-and-repeat <task>)
; This repeatedly executes the task until further notice.
;
; (cmd:execute-then-resume <task>)
; This interrupts the current task to execute the given task.  When the given task is done,
; the command processor resumes the previous task where it left off.
;
; (cmd:execute-then-restart <task>)
; This interrupts the current task to execute the given task.  When the given task is done,
; the command processor restarts the previous task.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'cmd)

; a do-nothing task
(define the-do-nothing-task (lambda m (begin (cmd:reset) #f)))

; this is the task that is called when the mouse goes down
(define cmd:mouse-down-task the-do-nothing-task)

;
; cmd:init and cmd:clear
;
; cmd:init must be called to initiate the command processor; call cmd:clear when the
; command processor is no longer needed.  Example:
;    (cmd:init)
;    (cmd:clear)
;
(begin
  (define cmd:init #f)
  (define cmd:clear #f)
  (let ((initialized #f)
        (old-mouse-down-hook #f)
        (old-mouse-up-hook #f)
        (old-error-handler #f))
    (set! cmd:init
          (lambda ( )
            (if (not initialized)
                (begin
                  ; save old hooks
                  (set! old-mouse-down-hook mouse-down-hook)
                  (set! old-mouse-up-hook mouse-up-hook)
                  (set! old-error-handler error-handler)
                  ; install new hooks
                  (set! mouse-down-hook (lambda (evnt)
                                          (cmd:mouse-down-task 'mouse-down evnt)))
                  (set! mouse-up-hook '( ))
                  ; Set up an error handler which will pop up an error dialog, and reset the command processor
                  (set! error-handler
                        (let ((error-string
                                (lambda (error-msg)
                                  (string-append
                                    (format #f "~s: " (car error-msg))
                                    (apply format `(#f ,@(cdr error-msg)))))))
                          (lambda error-msg
                            (cmd:reset)
                            (system:bell)
                            (ui:error-dialog (error-string error-msg)))))
                  ; reset the command processor
                  (cmd:reset)
                  ; flag the fact that we have initialized
                  (set! initialized #t)))))
    (set! cmd:clear
          (lambda ( )
            (if initialized
                (begin
                  ; restore old hooks
                  (set! mouse-down-hook old-mouse-down-hook)
                  (set! mouse-up-hook old-mouse-up-hook)
                  (set! error-handler old-error-handler)
                  ; indicate we're not initialized
                  (set! initialized #f)))))))

;
; cmd:reset
;
; Call this to reset the command processor to its initial state.
;
(define cmd:reset
  (lambda ( )
    ; set the current task so that it does nothing
    (set! cmd:mouse-down-task the-do-nothing-task)
    ; not sure why this is needed, but it was in old code (although not in cmd:reset?)
    (rbd:clear)
    ; initialize prompt
    (ui:prompt " ")
    ; reset restart and abort procedures
    (cmd:%reset-restart-and-abort)))

;
; cmd:interrupt-task?
;
; Returns #t if the currently executing task is an interrupt task, that is, if it is
; interrupting another task.  This can be used in conjunction with the cmd:abort-task function
; to 'pop' tasks off the stack of tasks until a 'base' (non interrupt) task is reached.
;
(define cmd:interrupt-task?
  (lambda ( )
    (cmd:mouse-down-task 'interrupt?)))

;
; cmd:abort-interrupts
;
(define cmd:abort-interrupts
  (lambda ( )
    (if (cmd:interrupt-task?)
        (begin (cmd:abort-task) (cmd:abort-interrupts)))))

;
; cmd:abort-task
;
; Aborts the current task.  If this task interrupted a task, then the interrupted task
; is reinstated (whether or not it is restarted depends on how the interrupting task
; was instated ... see cmd:interrupt-then-... functions.
(define cmd:abort-task #f)

;
; cmd:restart-task
;
; Restarts the current task.
;
(define cmd:restart-task #f)

(define cmd:%reset-restart-and-abort
  (lambda ( )
    (set! cmd:abort-task (lambda ( ) (cmd:mouse-down-task 'abort)))
    (set! cmd:restart-task (lambda ( ) (cmd:mouse-down-task 'restart)))
    'ok))

(define cmd:syntax-error
  (lambda (str)
    (error "Command processor" str)))

; cmd:make-task just returns a vector containing the task description, after doing some
; simple error checking
(begin
  (define cmd:task-target #f)
  (define cmd:task-preprocessor #f)
  (define cmd:task-postprocessor #f)
  (define cmd:task-arguments #f)
  (define cmd:make-task #f)
  (let ((target-tag "target")
        (pre-tag "pre")
        (post-tag "post")
        (arg-tag "arg"))
    (set! cmd:task-target (lambda (x) (vector target-tag x)))
    (set! cmd:task-preprocessor (lambda (x) (vector pre-tag x)))
    (set! cmd:task-postprocessor (lambda (x) (vector post-tag x)))
    (set! cmd:task-arguments (lambda m (vector arg-tag (apply vector m))))
    (set! cmd:make-task
          (lambda m
            (let ((I (lambda (x) x))
                  ; this function searches through the arguments to cmd:make-task looking
                  ; for a particalar argument (indicated by the given tag, eg target-tag).  If
                  ; such an argument was provided, it is returned, otherwise #f is returned
                  (find-arg
                    (lambda (arg-string)
                      (letrec ((search
                                 (lambda (args)
                                   (if (null? args)
                                       #f
                                       (if (eq? arg-string (vector-ref (car args) 0))
                                           (vector-ref (car args) 1)
                                           (search (cdr args)))))))
                        (search m)))))
              ; now fetch the arguments that were provided
              (let ((target (find-arg target-tag))
                    (pre (find-arg pre-tag))
                    (post (find-arg post-tag))
                    (args (find-arg arg-tag)))
                ; check that at a minimum a target was provided
                (if (not target)
                    (cmd:syntax-error "The cmd:task-target is a required input to cmd:make-task"))
                ; if not provided, the pre and post processor functions should be I, and the
                ; arguments to be collected should be the empty vector
                (let ((preprocess (if pre pre I))
                      (postprocess (if post post I))
                      (args (if args args (vector))))
                  ; do some simple checking
                  (if (not (procedure? target))
                      (cmd:syntax-error "Target must be a procedure"))
                  (if (or (not (procedure? preprocess))
                          (not (procedure? postprocess)))
                      (cmd:syntax-error "Pre and post processors must be procedures"))
                  ; so far so good; now return a vector representing the task
                  (vector target args preprocess postprocess))))))))

(define cmd:make-argument
  (lambda (do-before do-after)
    ; check that the user remembered to use cmd:arg
    (for-each
      (lambda (instrs)
        (if (or (not (procedure? instrs))
                (not (= (length (cadr (procedure-lambda instrs))) 6)))
            (cmd:syntax-error "Use cmd:arg to specify instruction sets")))
      (list do-before do-after))
    (vector do-before do-after)))

(define cmd:arg
  (macro instructions
    `(lambda (args-so-far  the-event  collect  discard again repeat)
       ,(cons 'begin instructions))))

;
; cmd:execute-...
;
(define cmd:execute
  (lambda (task)
    (set! cmd:mouse-down-task
          (cmd:%make-task
            task
            (lambda ( ) (cmd:reset))
            #f))))

(define cmd:execute-and-repeat
  (lambda (task)
    (set! cmd:mouse-down-task
          (cmd:%make-task
            task
            (lambda ( )
              (cmd:execute-and-repeat task))
            #f))
    'ok))

(define cmd:execute-then-resume
  (lambda (task)
    (let ((old-task cmd:mouse-down-task))
      (set! cmd:mouse-down-task
            (cmd:%make-task
              task
              (lambda ( )
                (old-task 'resume)
                (set! cmd:mouse-down-task old-task))
              #t))
      'ok)))

(define cmd:execute-then-restart
  (lambda (task)
    (let ((old-task cmd:mouse-down-task))
      (set! cmd:mouse-down-task
            (cmd:%make-task
              task
              (lambda ( )
                (old-task 'restart)
                (set! cmd:mouse-down-task old-task))
              #t))
      'ok)))

;
; cmd:%make-task
;
; This returns an object that responds to the following messages:
;
; restart
; Resets the task so that the next argument to be collected is the first.  The do-before
; instructions of the first argument to be collected are executed.
;
; abort
; Aborts the execution of this task
;
; mouse-down
; responds to a mouse down event
;
; resume
; resumes after interruption
;
; interrupt?
; returns #t if this task is interrupting another
;
; invoke-target invokes the target on the collected arguments
(define cmd:%make-task
  (lambda (task abort-continuation interrupt)
    (letrec
      ; get the task elements
      ((task->target (vector-ref task 0))
       (task->args (vector-ref task 1))
       (task->preprocess (vector-ref task 2))
       (task->postprocess (vector-ref task 3))
       (arg->do-before (lambda (arg) (vector-ref arg 0)))
       (arg->do-after (lambda (arg) (vector-ref arg 1)))
       ; a procedure to run when the task is resumed.
       (do-before (lambda ( ) 'ok))
       ; the task itself
       (this
         (letrec

           ; the number of arguments to be collected
           ((number-of-arguments (vector-length task->args))

            ; the last event
            (last-event #f)

            ; what to do when the next event arrives.  This takes an event and an
            ; escape procedure
            (next-event-processor (lambda (evt k) 'ok))

            ; the arguments collected so far
            (args-collected '( ))

            ; a help function for building next-event-processor
            (event-continuation
              (lambda (collected-so-far k)
                ; save do-before proc, then invoke it
                (set! do-before
                      (lambda ( )
                        (process-arg-func
                          (arg->do-before (vector-ref task->args collected-so-far))
                          last-event k)))
                (do-before)
                ; we output a function that takes an event and a continuation
                (lambda (evnt k)
                  (begin
                    ; process the current argument
                    (process-arg-func
                      (arg->do-after (vector-ref task->args collected-so-far)) evnt  k)
                    ; record this event
                    (set! last-event evnt)
                    ; either there are no more arguments to process, in which case it
                    ; is time to invoke the target function, or we need to collect
                    ; another argument
                    (if (= collected-so-far (- number-of-arguments 1))
                        ; we're done collecting
                        (this 'invoke-target)
                        ; collect more arguments
                        (set! next-event-processor
                              (event-continuation (+ collected-so-far 1) k)))))))

            ; process-arg-func executes a cmd:arg set of instructions
            (process-arg-func
              (lambda (arg-func evnt k)
                ; arg is the argument description for the current argument
                (let ((old-args-collected args-collected)
                      ; now build the continuations that will be passed to the
                      ; do-after set of instructions
                      (again (lambda ( )
                               (set! args-collected old-args-collected) (this 'resume) (k 2)))
                      (repeat  (lambda ( ) (this 'resume) (k 3)))
                      (args-so-far (lambda ( ) (reverse args-collected)))
                      (the-event (lambda ( ) evnt))
                      (collect (lambda (obj)
                                 (set! args-collected (cons obj args-collected)) 'ok))
                      (discard (letrec
                                 ((remove
                                    (lambda (obj list)
                                      (if (null? list)
                                          '( )
                                          (if (eq? obj (car list))
                                              (cdr list)
                                              (cons (car list) (remove obj (cdr list))))))))
                                 (lambda (obj)
                                   (set! args-collected (remove obj args-collected))))))
                  (begin
                    ; change definitions of cmd:restart-task and cmd:abort-task so
                    ; that the instruction set being executed is aborted if they are called
                    (set! cmd:restart-task (lambda ( ) (this 'restart) (k 0)))
                    (set! cmd:abort-task (lambda ( ) (this 'abort) (k 1)))
                    (arg-func args-so-far  the-event collect discard again repeat)
                    (cmd:%reset-restart-and-abort))))))

           ; the function to be assigned to "this"
           (lambda m
             (let ((msg (car m)))
               (cond

                 ; interrupt
                 ((eq? msg 'interrupt?)
                  interrupt)

                 ; restart
                 ((eq? msg 'restart)
                  (set! args-collected '( ))
                  (set! last-event #f)
                  (if (= number-of-arguments 0)
                      ; oddly, this task contains NO arguments to collect
                      (this 'invoke-target)
                      ; start collecting from the beginning
                      (call-with-current-continuation
                        (lambda (k)
                          (set! next-event-processor (event-continuation 0 k)))))
                  'ok)

                 ; abort
                 ((eq? msg 'abort)
                  (abort-continuation))

                 ; invoke-target
                 ((eq? msg 'invoke-target)
                  ; provide an escape continuation
                  (begin
                    (call-with-current-continuation
                      (lambda (k)
                        (set! cmd:restart-task (lambda ( ) (this 'restart) (k 4)))
                        (set! cmd:abort-task (lambda ( ) (this 'abort) (k 5)))
                        ; reverse the arguments
                        (let ((pre-args (reverse args-collected)))
                          ; call the task's arguments preprocessor
                          (let ((args (task->preprocess pre-args)))
                            ; call the target
                            (let ((result (apply task->target args)))
                              ; call the task's post processor
                              (task->postprocess result)
                              ; and abort the task
                              (this 'abort))))))
                    (cmd:%reset-restart-and-abort)))

                 ; resume
                 ((eq? msg 'resume)
                  ; all we need to do is to re-call the current argument's do-before
                  ; instruction set
                  (do-before))

                 ; mouse-down
                 ((eq? msg 'mouse-down)
                  (begin
                    (call-with-current-continuation
                      ; the continuation, k, is used as an "escape procedure".  At any time
                      ; it can be invoked (it is a one-argument procedure), causing the
                      ; call to next-event-continuation to return immediately.  We use
                      ; the continuation to implement the (abort), (restart), and (again)
                      ; procedures that may be used in argument descriptions.
                      (lambda (k)
                        (next-event-processor (cadr m) k)))
                    (cmd:%reset-restart-and-abort)))))))))

      ;; restart this task before returning it
      (begin
        (this 'restart)
        this))))

; end of file: cmdproc.scm
